The Arsenal Files 6/The Arsenal Files 6 (Arsenal Computer).ISO/prg_basi/ddfedit.zip/DDFFIELD.FRM

Text File | 1996-02-05 | 15KB | 575 lines

VERSION 2.00
Begin Form FormFieldDDF
   BackColor       =   &H00C0C0C0&
   Caption         =   "Fields For"
   ClientHeight    =   3390
   ClientLeft      =   1485
   ClientTop       =   2610
   ClientWidth     =   5475
   Height          =   3795
   Left            =   1425
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3390
   ScaleWidth      =   5475
   Top             =   2265
   Width           =   5595
   Begin CommandButton FldCom
      Caption         =   "&Down"
      Height          =   255
      Index           =   4
      Left            =   3000
      TabIndex        =   13
      Top             =   0
      Width           =   735
   End
   Begin SSPanel PanTop
      Align           =   1  'Align Top
      AutoSize        =   3  'AutoSize Child To Panel
      BevelOuter      =   0  'None
      BorderWidth     =   1
      Height          =   495
      Left            =   0
      TabIndex        =   7
      Top             =   0
      Width           =   5475
      Begin CommandButton FldCom
         Caption         =   "&Delete"
         Height          =   255
         Index           =   2
         Left            =   1440
         TabIndex        =   14
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&Up"
         Height          =   255
         Index           =   3
         Left            =   2280
         TabIndex        =   12
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&Edit"
         Height          =   255
         Index           =   1
         Left            =   720
         TabIndex        =   11
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&New"
         Height          =   255
         Index           =   0
         Left            =   0
         TabIndex        =   10
         Top             =   0
         Width           =   735
      End
      Begin SSPanel PanHead
         AutoSize        =   3  'AutoSize Child To Panel
         BevelInner      =   1  'Inset
         BevelOuter      =   0  'None
         BorderWidth     =   1
         Height          =   255
         Left            =   0
         TabIndex        =   8
         Top             =   240
         Width           =   5475
         Begin TextBox TextTop
            BackColor       =   &H00C0C0C0&
            BorderStyle     =   0  'None
            Enabled         =   0   'False
            ForeColor       =   &H00FF0000&
            Height          =   195
            Left            =   30
            MultiLine       =   -1  'True
            TabIndex        =   9
            Text            =   "test test test"
            Top             =   30
            Width           =   5415
         End
      End
   End
   Begin TextBox XPath
      Height          =   285
      Left            =   0
      TabIndex        =   6
      Top             =   2280
      Visible         =   0   'False
      Width           =   180
   End
   Begin TextBox XFDFlags
      Height          =   285
      Left            =   960
      TabIndex        =   5
      Top             =   2280
      Visible         =   0   'False
      Width           =   180
   End
   Begin TextBox XFDLocation
      Height          =   285
      Left            =   720
      TabIndex        =   4
      Top             =   2280
      Visible         =   0   'False
      Width           =   180
   End
   Begin TextBox XFDName
      Height          =   285
      Left            =   480
      TabIndex        =   3
      Top             =   2280
      Visible         =   0   'False
      Width           =   180
   End
   Begin TextBox XFDid
      Height          =   285
      Left            =   240
      TabIndex        =   2
      Top             =   2280
      Visible         =   0   'False
      Width           =   180
   End
   Begin SSPanel PanList
      AutoSize        =   3  'AutoSize Child To Panel
      BevelInner      =   1  'Inset
      BevelOuter      =   0  'None
      BorderWidth     =   1
      Height          =   1650
      Left            =   0
      TabIndex        =   0
      Top             =   1320
      Width           =   4815
      Begin ListBox Llist
         Height          =   1590
         Left            =   30
         TabIndex        =   1
         Top             =   30
         Width           =   4755
      End
   End
End
Option Explicit
Dim CurrentOffset As Integer
Dim inited As Integer
Dim Local_File_Changed As Integer
Dim FieldArr() As XDField_def
Dim FieldLast As Integer
Dim CurrListIndex As Integer

Sub Arrfill ()
  Dim Keybuf As KeyBufDef
  Dim KeyBufLen As Integer
  Dim XDField As XDField_def
  Dim BufLen As Integer
  Dim stat As Integer
  Dim PosBlk As PosBlkDef
  Dim FileFullPath As String
  Dim X As Integer
  Dim XDFieldKey1 As XDFieldKey1_def
  Dim i As Integer
  Dim j As Integer
  Dim p1 As Integer
  Dim p2 As Integer

  Debug.Print "listfill"

  llist.Clear

  KeyBufLen = Len(Keybuf)
  BufLen = Len(XDField)

  ' first open the file
  FileFullPath = XPath & "Field.DDF"
  Keybuf.kb = FileFullPath
  KeyBufLen = Len(Keybuf)
  BufLen = 0

  stat = btrcall(B_OPEN, PosBlk, XDField, BufLen, Keybuf, KeyBufLen, 0)
  If stat <> 0 Then
    MsgBox "Btrieve Error Opening file " & FileFullPath & Chr(10) & stat & " " & BtErr(stat)
    Exit Sub
  End If


  KeyBufLen = Len(XDFieldKey1): BufLen = Len(XDField)
  XDFieldKey1.XeDFile = Val(XFDid.Text)
  stat = btrcall(B_GETGE, PosBlk, XDField, BufLen, XDFieldKey1, KeyBufLen, 1)

  CurrentOffset = 0
  FieldLast = 0
  Do
    If stat <> 0 Then Exit Do

    If XDField.XeDFile <> Val(XFDid.Text) Then Exit Do

    CurrListIndex = 0
    ReDim Preserve FieldArr(FieldLast)
    FieldArr(FieldLast) = XDField
    FieldLast = FieldLast + 1

    KeyBufLen = Len(XDFieldKey1): BufLen = Len(XDField)
    stat = btrcall(B_GETNX, PosBlk, XDField, BufLen, XDFieldKey1, KeyBufLen, 1)

  Loop

  If (stat <> 9 And stat <> 0) Then MsgBox "Btrieve Error Retrieving Record in FILE file " & Chr(10) & stat & " " & BtErr(stat)
  stat = btrcall(B_CLOSE, PosBlk, XDField, BufLen, Keybuf, KeyBufLen, 0)

End Sub

Sub FieldDelete ()
  Dim CurIdx As Integer

  CurIdx = llist.ListIndex

  If CurIdx = -1 Then Exit Sub


  If IsFieldInIndexes(FieldArr(CurIdx).XeDid) Then
    MsgBox "Field is used in Indexes and cannot be changed", , "ERROR"
    Exit Sub
  End If


  llist.RemoveItem CurIdx


  If CurIdx > llist.ListCount - 1 Then
    CurrListIndex = llist.ListCount - 1
  Else
    CurrListIndex = CurIdx
  End If

  ListExtract
  ListAdjust
  listfill
  Local_File_Changed = True



End Sub

Sub FieldEdit ()
  Dim fIdx As Integer
  fIdx = llist.ListIndex
  If fIdx = -1 Then Exit Sub

  If IsFieldInIndexes(FieldArr(fIdx).XeDid) Then
    MsgBox "Field is used in Indexes and cannot be changed", , "ERROR"
    Exit Sub
  End If


  Curr_file_Changed = Local_File_Changed


  Load FormNewField
  FormNewField.NewFieldName.Text = FieldArr(fIdx).XeDName
  FormNewField.NewFieldDataType.Text = Format(Asc(FieldArr(fIdx).XeDDataType), "0")
  FormNewField.NewFieldSize = Format(FieldArr(fIdx).XeDSize, "0")
  FormNewField.NewFieldDec = Format(Asc(FieldArr(fIdx).XedDec), "0")

  FormNewField.XFDid.Text = Trim(XFDid.Text)
  FormNewField.XPath.Text = Trim(XPath.Text)
  FormNewField.FieldIdx = fIdx
  FormNewField.Show 1
  Local_File_Changed = Curr_file_Changed
  If Local_File_Changed Then
    ListExtract
    ListAdjust
    CurrListIndex = FieldLast - 1
    listfill
  End If


End Sub

Sub FieldMove (WhichWay As Integer)
  Dim CurIdx As Integer, NewIdx As Integer
  Dim i As Integer
  Dim TempArr As XDField_def

  CurIdx = llist.ListIndex

  If CurIdx = -1 Then Exit Sub

  NewIdx = CurIdx + WhichWay
  If NewIdx < 0 Then Exit Sub
  If NewIdx > llist.ListCount - 1 Then Exit Sub

  TempArr = FieldArr(NewIdx)
  FieldArr(NewIdx) = FieldArr(CurIdx)
  FieldArr(CurIdx) = TempArr

  ListAdjust
  CurrListIndex = NewIdx
  listfill
  Local_File_Changed = True



End Sub

Sub FieldNew ()
  Curr_file_Changed = Local_File_Changed
  Load FormNewField

  FormNewField.XFDid.Text = XFDid.Text
  FormNewField.XPath.Text = XPath.Text
  FormNewField.FieldIdx = -1
  FormNewField.Show 1
  Local_File_Changed = Curr_file_Changed
  If Local_File_Changed Then
    ListExtract
    ListAdjust
    CurrListIndex = FieldLast - 1
    listfill
  End If

End Sub

Sub Fields_Add ()
  ' Add all Fields to the current file XeDid
  ' XPath & Field.ddf

  Dim stat As Integer
  Dim KeyNum As Integer
  Dim PosBlk As PosBlkDef
  Dim Keybuf As KeyBufDef
  Dim KeyBufLen As Integer
  Dim BufLen As Integer
  Dim FileFullPath As String
  Dim XDField As XDField_def
  Dim i As Integer, r As Integer

' ************************************************************************************
' Now we add records to the FIELD.DDF file
' ************************************************************************************

  FileFullPath = XPath.Text & "FIELD.DDF"
  Keybuf.kb = FileFullPath
  KeyBufLen = Len(Keybuf)
  BufLen = 0

  status "Adding Fields to file " & FileFullPath

  stat = btrcall(B_OPEN, PosBlk, XDField, BufLen, Keybuf, KeyBufLen, 0)
  If stat <> 0 Then
    MsgBox "Btrieve Error Opening file " & FileFullPath & Chr(10) & stat & " " & BtErr(stat)
    Exit Sub
  End If

  ' Records for FILE.DDF

  For i = 0 To FieldLast - 1
    r = AddRecordToFieldDDF(PosBlk, (Val(XFDid.Text)), (FieldArr(i).XeDName), (Asc(FieldArr(i).XeDDataType)), (FieldArr(i).XeDOffset), (FieldArr(i).XeDSize), (Asc(FieldArr(i).XedDec)), 0)
  Next i

  stat = btrcall(B_CLOSE, PosBlk, XDField, BufLen, Keybuf, KeyBufLen, 0)


End Sub

Sub FldCom_Click (Index As Integer)
  Select Case Index
    Case 0: FieldNew 'new field
    Case 1: FieldEdit ' edit field
    Case 2: FieldDelete ' delete field
    Case 3: FieldMove (-1)' Move Field Up
    Case 4: FieldMove (1) ' Move Field Down

  End Select
End Sub

Sub Form_Activate ()
  Debug.Print "Activated"
  If inited Then Exit Sub
  Me.Caption = "Fields for """ & Trim(XfDName.Text) & """ (" & Trim(XFDLocation.Text) & ")"
  If Val(XFDFlags.Text) = 16 Then
    FldCom(0).Enabled = False
    FldCom(1).Enabled = False
    FldCom(2).Enabled = False
    FldCom(3).Enabled = False
    FldCom(4).Enabled = False
  End If
  Arrfill
  listfill
  If inited = False Then inited = True

End Sub

Sub Form_Load ()

  CurrListIndex = -1
  Local_File_Changed = False

  inited = False
End Sub

Sub Form_Resize ()
  If windowstate = 1 Then Exit Sub
  PanHead.Left = 0
  PanHead.Width = PanTop.Width
  PanList.Left = 0
  PanList.Width = ScaleWidth
  PanList.Top = PanTop.Height
  PanList.Height = ScaleHeight - PanList.Top
End Sub

Sub Form_Unload (Cancel As Integer)
  Dim r As Integer
  If Local_File_Changed Then
    r = MsgBox("Changes Made : Do you wish to save Changes ?", 3 + 32, "Fields Changed")
    Select Case r
      Case 2
        Cancel = True
      Case 6
        Fields_Remove (XPath.Text), (Val(XFDid.Text))
        Fields_Add
    End Select
  End If
End Sub

Function IsFieldInIndexes (FieldId As Integer)

  Dim Keybuf As KeyBufDef
  Dim KeyBufLen As Integer
  Dim XDIndex As XDIndex_def
  Dim BufLen As Integer
  Dim stat As Integer
  Dim PosBlk As PosBlkDef
  Dim FileFullPath As String
  Dim XDIndexKey0 As XDIndexKey0_def
  Dim Found As Integer


  KeyBufLen = Len(Keybuf)
  BufLen = Len(XDIndex)


  FileFullPath = XPath & "Index.DDF"
  Keybuf.kb = FileFullPath
  KeyBufLen = Len(Keybuf)
  BufLen = 0

  stat = btrcall(B_OPEN, PosBlk, XDIndex, BufLen, Keybuf, KeyBufLen, 0)
  If stat <> 0 Then
    MsgBox "Btrieve Error Opening file " & FileFullPath & Chr(10) & stat & " " & BtErr(stat)
    Exit Function
  End If


  KeyBufLen = Len(XDIndexKey0): BufLen = Len(XDIndex)
  XDIndexKey0.XiDFile = Val(XFDid.Text)
  stat = btrcall(B_GETGE, PosBlk, XDIndex, BufLen, XDIndexKey0, KeyBufLen, 0)


  Found = False
  Do
    If stat <> 0 Then Exit Do
    If XDIndex.XiDFile <> Val(XFDid.Text) Then Exit Do
    If XDIndex.XidField = FieldId Then
      Found = True
      Exit Do
    End If

    KeyBufLen = Len(XDIndexKey0): BufLen = Len(XDIndex)
    stat = btrcall(B_GETNX, PosBlk, XDIndex, BufLen, XDIndexKey0, KeyBufLen, 0)

  Loop

  If (stat <> 9 And stat <> 0) Then MsgBox "Btrieve Error Retrieving Record in FILE file " & Chr(10) & stat & " " & BtErr(stat)
  stat = btrcall(B_CLOSE, PosBlk, XDIndex, BufLen, Keybuf, KeyBufLen, 0)

  IsFieldInIndexes = Found


End Function

Sub ListAdjust ()
  Dim i As Integer
  Dim NewOff As Integer

  NewOff = 0
  For i = 0 To FieldLast - 1
    FieldArr(i).XeDid = i + 1
    FieldArr(i).XeDFile = Val(XFDid.Text)
    FieldArr(i).XeDOffset = NewOff
    NewOff = NewOff + FieldArr(i).XeDSize
  Next i

  CurrentOffset = NewOff
End Sub

Sub ListExtract ()
  Dim i As Integer
  Dim ll As String
  Dim p1 As Integer, p2 As Integer
  Dim NewOff As Integer


' first extract values from list into array

  FieldLast = llist.ListCount
  For i = 0 To FieldLast - 1
    ReDim Preserve FieldArr(i)
    ll = llist.List(i)

    FieldArr(i).XeDid = -1 ' Will need to be recalculated starting from last
    FieldArr(i).XeDFile = Val(XFDid.Text) ' the ID of the file


' XDField.XeDName
    p1 = 1: p2 = InStr(p1, ll, Chr(9))
    FieldArr(i).XeDName = Mid(ll, p1, p2 - p1)

' Format(Asc(XDField.XeDDataType), "0")
    p1 = p2 + 1: p2 = InStr(p1, ll, Chr(9))
    FieldArr(i).XeDDataType = Chr(Val(Mid(ll, p1, p2 - p1)))

' XDField.XeDOffset
    p1 = p2 + 1: p2 = InStr(p1, ll, Chr(9))
    FieldArr(i).XeDOffset = Val(Mid(ll, p1, p2 - p1))

' XDField.XeDSize
    p1 = p2 + 1: p2 = InStr(p1, ll, Chr(9))
    FieldArr(i).XeDSize = Val(Mid(ll, p1, p2 - p1))

' Format(Asc(XDField.XeDDec), "0")
    p1 = p2 + 1: p2 = InStr(p1, ll, Chr(9))
    FieldArr(i).XedDec = Chr(Val(Mid(ll, p1, p2 - p1)))

' XDField.XeDFlags
    p1 = p2 + 1
    FieldArr(i).XeDFlags = Val(Mid(ll, p1))
  Next i


  ' Now readjust the offset and the field numbers


End Sub

Sub listfill ()
  Dim i As Integer

  llist.Clear

  Texttop.Text = "Name" & Chr(9) & "DataType" & Chr(9) & "Offset" & Chr(9) & "Size" & Chr(9) & "Dec" & Chr(9) & "Flags"

  For i = 0 To FieldLast - 1
    llist.AddItem FieldArr(i).XeDName & Chr(9) & Format(Asc(FieldArr(i).XeDDataType), "0") & Chr(9) & FieldArr(i).XeDOffset & Chr(9) & FieldArr(i).XeDSize & Chr(9) & Format(Asc(FieldArr(i).XedDec), "0") & Chr(9) & Format(FieldArr(i).XeDFlags, "0")
    llist.ItemData(llist.NewIndex) = FieldArr(i).XeDid
  Next i
  llist.ListIndex = CurrListIndex

  i = AutoSetTabStopsCheck(llist, Texttop, False, False)

End Sub